home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 02 - 1986 / 02.11 Nov 86.sit / 02.11 Nov 86 / macscheme article stuff / scheme source / GraphicsObjects.sch
Encoding:
Text File  |  1986-06-07  |  4.2 KB  |  147 lines  |  [TEXT/MACA]

  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;newgraphicsobjects
  3. ;;;a program that demonstrates graphics and
  4. ;;;object-oriented programming in MacScheme 1.11
  5. ;;;copyright 1986, MacTutor Magazine
  6. ;;;written by Andrew Shalit  (617) 498-6637
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8.  
  9. ;;;constructors for building points and rectangles
  10. ;;A point is a simple pair of coordinates : (x . y)
  11. (define (make-point x . y)
  12.     (if    (point? x)
  13.         x
  14.         (cons x (car y))))
  15. ;;a rectangle is a list of two points: ((x1 . y1) (x2 . y2))
  16. (define (make-rect first-coord . other-coords)
  17.     (if    (rectangle? first-coord)
  18.         first-coord
  19.         (let ((first-other (car other-coords)))
  20.             (if    (point? first-coord)
  21.                 (list    first-coord
  22.                         (if    (point? first-other)
  23.                             first-other
  24.                             (apply make-point other-coords)))
  25.                 (apply    make-rect
  26.                         (cons    (make-point
  27.                                     first-coord first-other)
  28.                                 (cdr other-coords)))))))
  29.  
  30. ;selectors for getting coordinates out of points and rectangles
  31. (define (x-coord point)
  32.     (car point))
  33. (define (y-coord point)
  34.     (cdr point))
  35. (define (left-top rectangle)
  36.     (car rectangle))
  37. (define (right-bottom rectangle)
  38.     (cadr rectangle))
  39. (define (left rectangle)
  40.     (x-coord (left-top rectangle)))
  41. (define (top rectangle)
  42.     (y-coord (left-top rectangle)))
  43. (define (right rectangle)
  44.     (x-coord (right-bottom rectangle)))
  45. (define (bottom rectangle)
  46.     (y-coord (right-bottom rectangle)))
  47.  
  48. ;;tests to determine whether something is a point or rectangle
  49. (define (point? object)
  50.     (if    (pair? object)
  51.             (and    (number? (car object))
  52.                     (number? (cdr object)))
  53.             ()))
  54. (define (rectangle? object)
  55.     (if    (pair? object)
  56.             (and    (point? (car object))
  57.                     (point? (cadr object)))
  58.             ()))
  59.  
  60. ;functions for adding and subtracting points
  61. (define (add-points point1 point2)
  62.     (cons    (+ (x-coord point1) (x-coord point2))
  63.             (+ (y-coord point1) (y-coord point2))))
  64. (define (subtract-points point1 point2)
  65.     (cons    (- (x-coord point1) (x-coord point2))
  66.             (- (y-coord point1) (y-coord point2))))
  67.  
  68. ;function for passing a rectangle to a graphics function
  69. (define (2-point-function the-function the-rectangle)
  70.     (the-function    (left the-rectangle)
  71.                     (top the-rectangle)
  72.                     (right the-rectangle)
  73.                     (bottom the-rectangle)))
  74.  
  75. ;;this is your basic oval that can draw, erase, invert itself,
  76. ;;tell its dimensions, and receive new dimensions
  77. (define (make-oval . oval-definition)
  78.     (let ((oval-definition (apply make-rect oval-definition)))
  79.         (lambda (message)
  80.             (if    (rectangle? message)
  81.                 (set! oval-definition message)
  82.                 (case message
  83.         (DRAW (2-point-function paint-oval oval-definition))
  84.         (ERASE (2-point-function erase-oval oval-definition))
  85.         (INVERT (2-point-function invert-oval oval-definition))
  86.         (DESCRIPTION oval-definition)
  87.         (else (error "make-oval can't handle that definition"
  88.                     message)))))))
  89.  
  90. ;;a grow-oval inherits all of the features of an oval, but can
  91. ;;also move and change size in more interesting ways
  92. (define (make-grow-oval . oval-def)
  93.     (let ((this-oval (apply make-oval oval-def)))
  94.         (lambda (the-change . the-amount)
  95.             (let    ((old-description (this-oval 'description))
  96.                   (real-amount
  97.                     (if    the-amount
  98.                         (apply make-point the-amount))))
  99.             (this-oval
  100.                 (case the-change
  101.                     (MOVE
  102.                         (make-rect
  103.                             (add-points
  104.                                 real-amount
  105.                                 (left-top old-description))
  106.                             (add-points
  107.                                 real-amount
  108.                                 (right-bottom old-description))))
  109.                     (MOVE-TO
  110.                         (make-rect
  111.                             real-amount
  112.                             (add-points
  113.                                     real-amount
  114.                                     (subtract-points
  115.                                         (right-bottom 
  116.                                             old-description)
  117.                                         (left-top 
  118.                                             old-description)))))
  119.                     (EXPAND
  120.                         (make-rect
  121.                             (subtract-points
  122.                                 (left-top old-description) 
  123.                                 real-amount)
  124.                             (add-points
  125.                                 real-amount
  126.                                 (right-bottom old-description))))
  127.                     (else the-change)))))))
  128.  
  129.  
  130. ;;;this procedure shows off some ovals
  131. (define (oval-sampler)
  132.     (let (    (oval-1 (make-grow-oval 5 5 50 50))
  133.             (oval-2 (make-grow-oval 100 20 130 40))
  134.             (oval-3 (make-grow-oval 30 90 60 120)))
  135.         (clear-graphics)
  136.         (oval-1 'draw)
  137.         (oval-2 'draw)
  138.         (oval-3 'draw)
  139.         (oval-1 'move 5 5)
  140.         (oval-1 'erase)
  141.         (oval-2 'expand 4 4)
  142.         (oval-2 'invert)
  143.         (oval-3 'move-to 40 60 70 90)
  144.         (oval-3 'draw)))
  145.  
  146.  
  147.